Business Shareware

home *** CD-ROM | disk | FTP | other *** search

/ Business Shareware / Business Shareware.iso / start / database / lib194 / misc.prg < prev next >

Wrap

Text File | 1993-01-08 | 51.6 KB | 1,408 lines

*------------------------------------------------------------------------------- *-- Program...: MISC.PRG *-- Programmer: Ken Mayer (CIS: 71333,1030) *-- Date......: 06/25/1992 *-- Notes.....: These are the miscellaneous functions/procedures from the PROC *-- file that aren't as commonly used as the others. See README.TXT *-- for details on how to use this library file. *-- The following functions have been copied from the appropriate *-- library files, and may be deleted if this program is simply *-- copied into the PROC.PRG file with STRINGS.PRG and CONVERT.PRG *-- files: *-- ATCOUNT() (from STRINGS.PRG) *-- DEC2HEX() (from CONVERT.PRG) *-- STRPBRK() (from STRINGS.PRG) *------------------------------------------------------------------------------- FUNCTION PlayIt *------------------------------------------------------------------------------- *-- Programmer..: Mike Carlisle (A-T) *-- Date........: 01/21/1992 *-- Notes.......: This function (from Technotes, issue??) will play a song *-- stored in a memory variable (array). *-- This is a two dimensional array, with the first dimension *-- defined being the # of notes, each note having two parts. *-- For a song with 12 notes, the declare statement is: *-- DECLARE aSong[12,2] *-- aSong[1,1] is the pitch of the first note. *-- aSong[1,2] is the duration of the first note. *-- Pitches are defined from C below Middle C to B below Middle C. *-- These are from a "tempered" scale. Values can be raised an *-- octave by doubling the number, lowered by halving it. *-- Duration can be from 1 to 20. *-- Note Value *-- C 261 *-- C# 277 *-- D 294 *-- D# 311 *-- E 329 *-- F 349 *-- F# 370 *-- G 392 *-- G# 415 *-- A 440 *-- A# 466 *-- B 494 *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 01/21/1992 - Modified to allow use of parameter to choose *-- the song to be played. This alleviates the need for the *-- procedures SONG1 and SONG2 and the memfile created by them. *-- Two songs are provided (see below) ... *-- Calls.......: None *-- Called by...: Any *-- Usage.......: PlayIt(<nSong>) *-- Example.....: @5,10 say "Enter last name: " get lName valid required *-- .not. empty(lName); *-- error PlayIt(1)+"There must be a lastname ..." *-- Read *-- && OR *-- ?? PlayIt(2) *-- Returns.....: Nul (or Beep on invalid parameter) *-- Parameters..: nSong = Song number. Programmer might consider adding to the *-- list below for any songs added for documentation *-- purposes ... *-- VALID VALUES/SONGS: *-- 1 = Dirge *-- 2 = "Touchdown" *------------------------------------------------------------------------------- parameter nSong private aSong, nCounter *-- check for valid type of parameter ... must be numeric ... if .not. type("nSong") $ "NF" return chr(7) endif *-- get the integer value of nSong ... in case someone tries a "fast one" nSong = int(nSong) *-- load song do case case nSong = 1 && dirge declare aSong[12,2] && 12 notes, 2 parts each store 220 to aSong[1,1] && pitch store 10 to aSong[1,2] && duration store 220 to aSong[2,1] store 10 to aSong[2,2] store 220 to aSong[3,1] store 2 to aSong[3,2] store 220 to aSong[4,1] store 10 to aSong[4,2] store 261.63 to aSong[5,1] store 7 to aSong[5,2] store 246.94 to aSong[6,1] store 2 to aSong[6,2] store 246.94 to aSong[7,1] store 5 to aSong[7,2] store 220 to aSong[8,1] store 5 to aSong[8,2] store 220 to aSong[9,1] store 5 to aSong[9,2] store 205 to aSong[10,1] store 5 to aSong[10,2] store 220 to aSong[11,1] store 15 to aSong[11,2] case nSong = 2 && "touchdown" declare aSong[7,2] && 7 notes, 2 parts each store 523.5 to aSong[1,1] && pitch store 2 to aSong[1,2] && duration store 587.33 to aSong[2,1] store 2 to aSong[2,2] store 659.29 to aSong[3,1] store 2 to aSong[3,2] store 783.99 to aSong[4,1] store 7 to aSong[4,2] store 659.29 to aSong[5,1] store 2 to aSong[5,2] store 783.99 to aSong[6,1] store 10 to aSong[6,2] otherwise && not song 1 or 2, return nothing return chr(7) endcase *-- playback nCounter = 1 do while type("aSong[nCounter,1]") = "N" set bell to aSong[nCounter,1],aSong[nCounter,2] ?? chr(7) at col() nCounter = nCounter + 1 enddo set bell to && return value to original RETURN "" *-- EoF: PlayIt() PROCEDURE PageEst *------------------------------------------------------------------------------- *-- Programmer..: Rachel Holmen (RAEHOLMEN) *-- Date........: 02/04/1992 *-- Notes.......: This procedure estimates the number of pages needed for an *-- output list. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 01/15/1992 - original procedure. *-- 02/04/1992 - Ken Mayer - overhaul to allow the sending of *-- parameters for fields, rather than hard coding. Attempted to *-- make this a "black box" procedure. *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: Do PageEst with <nCount>,"<cReport>",<nRecords> *-- Example.....: Use printers *-- Do PageEst with 0,"Printer for 'Hew' $ Brand",55 *-- Returns.....: None *-- Parameters..: nCount = record count for records to be printed ... *-- if sent as "0", system will do a RECCOUNT() for you *-- cReport = name of report, with any filters ... (FOR ...) *-- nRecords = number of records per page the report will handle. *-- if sent as "0", system will assume 60 ... *------------------------------------------------------------------------------- parameters nCount,cReport,nRecords private cReport2,nPos,nPage,cPage,cChoice,cCursor cReport2 = upper(cReport) *-- make sure we have a number of records to work with ... if nCount = 0 if at("FOR",cReport2) > 0 && if a filter, extract the filter npos = at("FOR",cReport2) && so we can count records that match cFilter = substr(cReport,Pos+3,len(cReport)-(npos-1)) count to nCount for &cFilter else nCount = reccount() endif endif if nRecords = 0 nRecords = 60 endif *-- calculate the number of pages for the report ... store int(nCount/nRecords) to nPage if mod(nCount,nRecords) > 45 store nPage+1 to nPage else store (nCount/nRecords) to nPage endif if nCount>0 .and. nCount < nRecords store 1 to nPage endif *-- deal with displaying info, and printing the report ... save screen to sPrinter activate screen && in case there are other windows on screen ... define window wPrinter from 8,15 to 15,65 double color rg+/gb,w/n,rg+/gb do shadow with 8,15,15,65 activate window wPrinter *-- figure out how much to tell the user ... if mod(nCount,nRecords) > 19 .and. mod(nCount,nRecords) < 46 store ltrim(str(nPage))+" and a half pages.)" to cPage else store ltrim(str(nPage))+" pages.)" to cPage endif if nPage = 1 store "one page.)" to cPage endif *-- display info ... do center with 1,50,"",; "There are "+ltrim(str(nCount))+" records." do center with 2,50,"","(That's approximately "+cPage *-- ask if they want to generate the report? store space(1) to cChoice @4,8 say "Do you want to print the list? " get cChoice picture "!" ; valid required cChoice $ "YN"; error chr(7)+"Enter 'Y' or 'N'!" read *-- if yes, do it ... if cChoice = "Y" clear && just this window ... do center with 2,50,"","Align paper in your printer." do center with 3,50,"","Press any key to continue ..." x=inkey(0) clear do center with 2,50,"","... Printing ... do not disturb ..." cCursor = set("CURSOR") set cursor off set console off report form &cReport to print set console on set cursor &cCursor endif *-- cleanup deactivate window wPrinter release window wPrinter restore screen from sPrinter release screen sPrinter RETURN *-- EoP: PageEst FUNCTION Permutes *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/1992 *-- Notes.......: Permutations of nNum items taken Nhowmany at a time *-- That is, the number of possible arrangements, as *-- the different ways a president, V.P. and sec'y may *-- be chosen from a club of 10 members *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Permutes(<nNum>,<nHowMany>) *-- Example.....: ?Permutes(10,3) *-- Returns.....: Numeric *-- Parameters..: nNum = number of items in the entire set *-- nHowMany = number to be used at once *------------------------------------------------------------------------------- parameters nNum, nHowmany private nResult, nCounter store 1 to nResult, nCounter do while nCounter <= nHowmany nResult = nResult * ( nNum + 1 - nCounter ) nCounter = nCounter + 1 enddo RETURN nResult *-- EoF: Permutes() FUNCTION Combos *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/1992 *-- Notes.......: Combinations, similar to Permutations *-- Combinations treat "1, 3" as the same as *-- "3, 1", unlike permutations. This gives the *-- games needed for a round robin and helps with *-- figuring odds of most state lotteries. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Combos(<nNum>,<nHowMany>) *-- Example.....: ?Combos(10,2) *-- Returns.....: Numeric *-- Parameters..: nNum = number of items in the entire set *-- nHowMany = number to be used at once *------------------------------------------------------------------------------- parameters nNum, nHowmany private nResult, nCounter store 1 to nResult, nCounter do while nCounter <= nHowmany nResult = nResult * ( nNum + 1 - nCounter ) / nCounter nCounter = nCounter + 1 enddo RETURN nResult *-- Combos() FUNCTION BinLoad *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/1992 *-- Notes.......: Function to manage .bin files *-- A call to this function results in the following actions: *-- *-- If the name of a binary module alone is given as the argument, *-- the module is loaded if necessary, and .T. is returned. *-- If the file cannot be found, returns .F. *-- An error occurring during the load will cause a dBASE error. *-- *-- If the argument "" is given, RELEASES all loaded modules and *-- returns .T. *-- *-- If the argument contains the name of a loaded binary file *-- and "/R", RELEASEs that file only and returns .T. If the *-- file is not listed in "gc_bins_in", returns .F. *-- *-- This function uses the public variable "gc_bins_in". It *-- keeps track of the modules loaded by changing the contents *-- of that variable. If modules are loaded or released without *-- the use of this function, the variable will contain an *-- inaccurate list of the modules loaded and problems will *-- almost surely occur if this function is used later. *-- *-- If more than 16 binary modules are requested over time through *-- this function, the one that was named least recently in a call *-- to load it by this function is released to make room for the *-- new one. This will not necessarily be the module last used, *-- unless care is taken to use this function to "reload" the *-- .bin before each call. *-- *-- Suggested syntax, to call the binary routine "Smedley.bin" *-- which takes and returns two arguments: *-- *-- IF binload( "Smedley" ) *-- CALL Smedley WITH Arg1, Arg2 *-- ELSE *-- ? "binary file not available" *-- ENDIF *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: ATCOUNT() Function in MISC.PRG *-- Called by...: Any *-- Usage.......: BinLoad(<cBinName>) *-- Example.....: ?BinLoad("Smedley") *-- Returns.....: Logical (.T. if successful ) *-- Parameters..: cBinName = name of bin file to load ... *------------------------------------------------------------------------------- parameters cBinname private cBin, nPlace, nTemp, lResult cBin = ltrim( trim( upper( cBinname ) ) ) if type( "gc_bins_in" ) = "U" public gc_bins_in gc_bins_in = "" endif lResult = .T. do case case "" = cBin do while "" # gc_bins_in nPlace = at( "*", gc_bins_in ) cBin = left( gc_bins_in, nPlace - 1 ) gc_bins_in = substr( gc_bins_in, nPlace + 1 ) release module &cBin enddo release gc_bins_in case "/R" $ cBinname cBin = trim( left( cBin, at( cBin, "/" ) - 1 ) ) if "." $ cBin cBin = left( cBin, at( ".", cBin ) - 1 ) endif nPlace = at( cBin, gc_bins_in ) if nPlace = 0 lResult = .F. else gc_bins_in = substr( gc_bins_in, nPlace + 1 ) release module &cBin endif otherwise if "." $ cBin cBin = left( cBin, at( ".", cBin ) - 1 ) endif if .not. file( cBin ) lResult = .F. else if atcount( "*", gc_bins_in ) > 15 nPlace = at( "*", gc_bins_in ) cTemp = left( gc_bins_in, nPlace - 1 ) release module &cTemp gc_bins_in = substr( gc_bins_in, nPlace + 1) endif load &cBin nPlace = at( cBin, gc_bins_in ) if Place > 0 gc_bins_in = stuff( gc_bins_in, nPlace, len( cBin ) + 1, "" ) endif gc_bins_in = gc_bins_in + cBin + "*" endif endcase RETURN lResult *-- EoF: BinLoad() FUNCTION DialUp *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 06/17/1992 *-- Notes.......: Dial the supplied telephone number. Returns .F. for error. *-- This is not a full communications routine. It is designed *-- to be used to place voice telephone calls, with the user *-- picking up the handset after using this function to dial. *-- *-- This will work only with a modem using the standard Hayes *-- commands, and only if the port has already been set to the *-- desired baud rate, etc., by the DOS MODE command or *-- otherwise. If the port and dialing method are not constant *-- for the application, rewrite the function to accept them as *-- additional parameters. *-- *-- Written for.: dBASE IV, 1.1, 1.5 *-- Rev. History: 03/01/1992 - original function. *-- 04/01/1992 - Jay Parsons - modified for Version 1.5. *-- 04/03/1992 - Jay Parsons - ferror() call added. *-- 06/17/1992 - Jay Parsons - 1.1 version changed to use *-- SET PRINTER TO Device rather than .bin. *-- Calls : Strpbrk() Function in MISC.PRG *-- Called by...: Any *-- Usage.......: DialUp(<cPhoneNo>) *-- Example.....: x = DialUp( "555-1212" ) *-- Returns.....: Logical (connect made or not) *-- Parameters..: cPhoneNo = Phone number to dial ... *-- Side effects: When used for versions before 1.1, sets the printer to *-- : a COM port and does not reset it. *----------------------------------------------------------------------- parameters cPhoneNo private cNumber, cPort, cDialtype, cCallarg, xTemp, nHandle,; cString, lResult cPort = "Com2" && specify Com1 or Com2 as required cDialtype = "Tone" && specify Tone or Pulse ( rotary ) dialing cNumber = cPhoneno if type( "cPhoneno" ) $ "NF" cNumber = ltrim( str( cPhoneno ) ) else do while .t. xTemp = Strpbrk( cNumber, " ()-" ) if xTemp = 0 exit endif cNumber = stuff( cNumber, xTemp, 1, "" ) enddo endif cString = "ATD" + upper( left( cDialtype, 1 ) ) + cNumber + chr(13 ) if val( substr( version(), 9, 5 ) ) < 1.5 SET PRINTER TO &cPort ??? Cstring lResult = .T. else nHandle = fopen( cPort, "w" ) if ferror() # 0 RETURN .F. endif lResult = ( fwrite( nHandle, cString ) = len( cString )) xTemp = fclose( nHandle ) endif RETURN lResult *-- EoF: Dialup() FUNCTION CurrPort *------------------------------------------------------------------------------- *-- Programmer..: David P. Brown (RHEEM) *-- Date........: 03/22/1992 *-- Notes.......: This procedure gets the current SET PRINTER TO information. *-- Will return a port or a filename if set to a file. This also *-- requires a DBF file called CURRPRT.DBF, with an MDX tag *-- set on the only field CURRPRT, which is a character field *-- of 80 characters. *-- *-- Structure for database: CURRPRT.DBF *-- Number of data records: 0 *-- Date of last update : 03/22/92 *-- Field Field Name Type Width Dec Index *-- 1 CURRPRT Character 80 Y *-- ** Total ** 81 *-- *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 03/18/1992 - original function. *-- 03/18/1992 -- Ken Mayer (CIS: 71333,1030) to clean it up a bit, and *-- make it a function (not requiring the public memvar that *-- was originally required). *-- 03/21/1992 -- David P. Brown (RHEEM) found bug while *-- selecting a previous work area (stored on cDBF). Changed *-- 'select cDBF' to 'select (cDBF)'. *-- 03/22/1992 -- David P. Brown (RHEEM) final revision. Added *-- check for no available work areas. If none is available *-- then the program returns a null. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: CurrPort() *-- Example.....: ? CurrPort() *-- Returns.....: the current port, as a character value *-- Port: LPTx:, COMx:, PRN: *-- File: Filename (with or without drive and path, depends *-- on how the user entered it in the SET command) *-- Other: Null (no work area available) *-- Parameters..: None *------------------------------------------------------------------------------- private cSafety, cConsole, cDBF, cPort *-- Check for available work area (safety check) if select() = 0 return "" endif *-- Setup cSafety = set("SAFETY") set safety off *-- so user can't see what's going on cConsole = set("CONSOLE") set console off if file("CURRPRT$.OUT") && if this file exists erase CURRPRT$.OUT && delete it, so we can write on it endif cDBF = alias() && get current work area, so we can return ... *-- Get current printer *-- note that we are not using 'Set Printer to file ...' due to the *-- fact that this will change the info that the 'LIST STAT' command *-- issues ... set alternate to currprt$.out && direct screen input to file set alternate on list status && returns environment information set alternate off && turn off 'capture' close alternate && close file 'currprt$.out' select select() && grab next available work area ... use currprt order currprt excl && open database called CURRPRT zap && clean out old copy of this file append from currprt$.out type sdf && import the data for manipulation seek "Print" *-- This is setup to do an indexed search, since the printer information *-- will not always be on the same line. If it were, we could issue a *-- 'GO <n>' command, which would speed up the routine. Somewhere on *-- line 8 to 12 (or record) is 'Print destination: <port/file>'. The *-- seek looks for the first word. The command below trims out the *-- first part of the line, and extra spaces as well. This will *-- return the information after the colon. cPort = upper(trim(right(currprt,60))) && always in upper case *-- clean up use if len(trim(cDBF)) > 0 select (cDBF) else select 1 endif *-- erase this file erase currprt$.out *-- return safety and console to previous states ... set safety &cSafety set console &cConsole RETURN cPort *-- EoF: CurrPort() FUNCTION FileLock *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 04/27/1992 *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book. *-- This routine modified by Ken Mayer to handle slightly *-- fancier processing ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows *-- and such. *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: FileLock("<cColor>") *-- Example.....: if FileLock("&cl_Wind1") *-- *-- pack/reindex/whatever you need to do to database *-- else *-- *-- do whatever processing necessary if file not *-- *-- available for locking at this time *-- endif *-- Returns.....: Logical (.t./.f.) *-- Parameters..: cColor = Color combination for window ... *------------------------------------------------------------------------------- parameters cColor private nCount,lLock,x,cCurNorm,cCurBox,cTempCol *-- deal with dBASE IV standard errors -- we don't want program bombing on error ?? *-- deal with screen stuff ... *-- get it started ... nCount = 1 && start at 1 lLock = .t. && assume true *-- try 100 times do while nCount <= 100 .and. .not. flock() .and. inkey() = 0 nCount = nCount + 1 enddo *-- if we can't lock the file, let the user know ... if .not. flock() lLock = .f. save screen to sLock *-- save colors cCurNorm = colorof("NORMAL") cCurBox = colorof("BOX") *-- set new colors cTempCol = colorbrk(cColor,1) set color of normal to &cTempCol cTempCol = colorbrk(cColor,3) set color of box to &cTempCol *-- define window, display message activate screen define window wLock from 10,15 to 18,65 double do shadow with 10,15,18,65 activate window sLock do center with 1,50,"","The file cannot be locked at this time" do center with 2,50,"","Please try again." x = inkey(0) *-- cleanup deactivate window wLock release window wLock restore screen from sLock release screen sLock *-- reset colors set color of normal to &cCurNorm set color of box to &cCurBox endif *-- clean up screen, etc. on error RETURN lLock *-- EoF: FileLock() FUNCTION RecLock *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 04/27/1992 *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book. *-- This function attempts to lock current record in active *-- database. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows *-- and such. *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: RecLock("<cColor>") *-- Example.....: if RecLock("&cl_Wind1") *-- *-- process record *-- else *-- *-- return to menu, or whatever processing your routine *-- *-- does at this point *-- endif *-- Returns.....: Logical (.t./.f.) *-- Parameters..: cColor = Color combination for window ... *------------------------------------------------------------------------------- parameters cColor private nCount, lLock, cRetry, cCurNorm, cCurBox, cTempCol *-- deal with dBASE IV standard errors -- we don't want program bombing on error ?? *-- deal with screen *-- start trying -- we will give the user the option to exit -- each time *-- they unsuccessfully lock the record. lLock = .t. && assume true do while .t. && main loop nCount = 1 && initialize each time we try ... *-- effectively a time-delay loop ... do while nCount <= 100 .and. .not. rLock() .and. inkey() = 0 nCount = nCount + 1 enddo *-- if we CAN lock it, we're done, get outta here ... if rlock() lLock = .t. exit else *-- otherwise, let the user know we couldn't do it, and ask if *-- they want to try again ... save screen to sLock *-- save colors cCurNorm = colorof("NORMAL") cCurBox = colorof("BOX") *-- set new colors cTempCol = colorbrk(cColor,1) set color of normal to &cTempCol cTempCol = colorbrk(cColor,3) set color of box to &cTempCol *-- define window ... activate screen define window wLock from 10,15 to 18,65 double do shadow with 10,15,18,65 activate window wLock lLock = .f. cRetry = 'N' @1,3 say "This record is being updated at another" @2,3 say "workstation. You can try again now," @3,3 say "to access the record, or return to it" @4,3 say "later." @6,3 say "Do you want to try again now? " get cRetry; picture "!"; valid required cRetry $ "YN"; error chr(7)+"Enter 'Y' or 'N'" read *-- cleanup deactivate window wLock release window wLock restore screen from sLock release screen sLock *-- reset colors set color of normal to &cCurNorm set color of box to &cCurBox if cRetry = "N" exit endif && cRetry = "N" endif && rLock() enddo && end of main loop *-- cleanup on error RETURN lLock *-- EoF: RecLock() FUNCTION UserId *------------------------------------------------------------------------------- *-- Programmer..: Angus Scott-Fleming (ANGUSSF) *-- Date........: 04/20/1992 *-- Notes.......: Returns log-in USER ID regardless of Network Type *-- *********************************************************** *-- ** IF DBASE IV VERSION IS < 1.5 THIS REQUIRES USERID.BIN ** *-- *********************************************************** *-- Written for.: dBASE IV v1.5, will work in 1.1, if you use EMPTY() *-- Rev. History: 10/27/1992 -- Ken Mayer cleaned up a tad ... *-- Calls.......: None if version 1.5, EMPTY() if version 1.1 *-- Called by...: Any *-- Usage.......: UserID() *-- Example.....: ? UserID() *-- Returns.....: Character String (up to 8 characters) *-- Parameters..: None *------------------------------------------------------------------------------- private cTemp if network() if .not. isblank(getenv("USERID")) *-- if you're working on a Lantastic net, USERID will lock the *-- system up. Use a DOS environment variable USERID instead. *-- This also works as a temporary override for testing access levels. cTemp = left(getenv("USERID"),8) else if val(right(version(),3)) => 1.5 && version 1.5 of dBASE IV cTemp = id() else cTemp = space(48) if file("USERID.BIN") load userid call userid with cTemp release module userid endif && file("USERID.BIN") endif && val(right...) endif && .not. isblank(getenv ... else cTemp = "" endif && network() RETURN left(cTemp,8) && which MIGHT be empty ... *-- EoF: UserID PROCEDURE DosShell *------------------------------------------------------------------------------- *-- Programmer..: Bowen Moursund (CIS: 76566,1405) *-- Date........: 06-10-1992 *-- Notes.......: Swaps out dBASE from memory, loads a DOS shell *-- Written for.: dBASE IV v1.5 *-- Rev. History: none *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do DosShell with <cAppName> *-- Example.....: do DosShell with "MyApp" *-- Parameters..: cAppName - the name of the application *------------------------------------------------------------------------------- parameter cAppName private cDir, lCursOff, cBatFile, nFH, nResult cAppName = iif(pcount() = 0, "the application", cAppName) private all cDir = set("directory") lCursOff = ( set("cursor") = "OFF" ) cBatFile = tempname("bat") + ".bat" nFH = fcreate(cBatFile) if nFH > 0 nBytes = fputs(nFH,"echo off") nBytes = fputs(nFH,"cls") nBytes = fputs(nFH,"echo " + chr(255)) && echo a blank line nBytes = fputs(nFH,"echo NOTE: Enter EXIT to resume " + cAppName + ".") nBytes = fwrite(nFH,getenv("comspec")) null = fclose(nFH) set cursor on nResult = run(.f., cBatFile, .t.) if nResult # 0 run &cBatFile endif erase (cBatFile) else cComSpec = getenv("comspec") set cursor on run &cComSpec. endif if lCursOff set cursor off endif set directory to &cDir RETURN *-- EoP: DosShell FUNCTION IsDisk *------------------------------------------------------------------------------- *-- Programmer...: Ken Mayer (CIS: 71333,1030) *-- Date.........: 07/13/1992 *-- Notes........: This routine is useful to check a drive for a valid disk in *-- in it (Valid means it is in the drive, with the door closed, *-- and is formatted ...). *-- *********************** *-- ** REQUIRES DISK.BIN ** *-- *********************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Called by...: None *-- Calls.......: CENTER Procedure in PROC.PRG *-- SHADOW Procedure in PROC.PRG *-- Usage.......: IsDisk(<cDrive>,<cMessCol>,<cErrCol>) *-- Example.....: IsDisk("cDrive","rg+/gb","rg+/r") *-- Returns.....: Logical *-- Parameters..: cDrive = drive name -- single letter, no colon (i.e., "A") *-- cMessCol = color for message bonX *-- cErrCol = color for error message *------------------------------------------------------------------------------- parameters cDrive, cMessCol, cErrCol private nX, cDrive2 *-- deal with message window save screen to sDisk activate screen define window wDisk from 9,15 to 12,65 double color &cMessCol,,&cMessCol do shadow with 9,15,12,65 activate window wDisk *-- display message ... do center with 0,50,"&cMessCol",; "Place disk in drive "+cDrive+": and close drive door." do center with 1,50,"&cMessCol",; "Press any key when ready ..." set cursor off nX=inkey(0) set cursor on deactivate window wDisk restore screen from sDisk *-- check for a valid drive. This uses the BIN file: DISK.BIN to do so. load disk && load the BIN file cDrive2 = cDrive && save the current setting in case there's a prob. call disk with cDrive2 && check to see if it's valid activate screen define window wDisk from 7,10 to 14,70 double color &cErrCol,,&cErrCol do while cDrive2 = 'X' && perform loop if value of cDrive2 is 'X' (error) do shadow with 7,10,14,70 activate window wDisk do center with 0,60,"&cErrCol",; "** DRIVE ERROR **" do center with 2,60,"&cErrCol",; "Check to make sure a valid (formatted) disk is in drive," do center with 3,60,"&cErrCol",; "and that the drive door is closed properly." do center with 5,60,"&cErrCol",; "Press <Esc> to exit, any other key to continue ..." set cursor off nX=inkey(0) set cursor on deactivate window wDisk restore screen from sDisk if nX = 27 && user pressed <Esc> release module disk release window wDisk release screen sDisk RETURN .F. endif cDrive2 = cDrive && reset cDrive2 from original call disk with cDrive2 && check for validity again ... enddo *-- cleanup release module Disk && remove module from RAM so we can continue restore screen from sDisk release screen sDisk release window wDisk RETURN .t. *-- EoF: IsDisk() *------------------------------------------------------------------------------- *-- The following are here as a courtesy ... *------------------------------------------------------------------------------- FUNCTION AtCount *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/92 *-- Notes.......: returns the number of times FindString is found in Bigstring *-- Written for.: dBASE IV *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: AtCount("<cFindStr>","<cBigStr>") *-- Example.....: ? AtCount("Test","This is a Test string, with Test data") *-- Returns.....: Numeric value *-- Parameters..: cFindStr = string to find in cBigStr *-- cBigStr = string to look in *------------------------------------------------------------------------------- parameters cFindstr, cBigstr private cTarget, nCount cTarget = cBigstr nCount = 0 do while .t. if at( cFindStr,cTarget ) > 0 nCount = nCount + 1 cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 ) else exit endif enddo RETURN nCount *-- EoF: AtCount() FUNCTION Dec2Hex *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/1992 *-- Notes.......: Converts an integral number ( in decimal notation) *-- to a hexadecimal string *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Dec2Hex(<nDecimal>) *-- Example.....: ? Dec2Hex( 118 ) *-- Returns.....: Character = Hexadecimal equivalent ( "F6" in example ) *-- Parameters..: nDecimal = number to convert *------------------------------------------------------------------------------- parameters nDecimal private nD, cH nD = int( nDecimal ) cH= "" do while nD > 0 cH = substr( "0123456789ABCDEF", mod( nD, 16 ) + 1 , 1 ) + cH nD = int( nD / 16 ) enddo RETURN iif( "" = cH, "0", cH ) *-- Eof: Dec2Hex() FUNCTION StrPBrk *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 03/01/92 *-- Notes.......: Search string for first occurrence of any of the *-- characters in charset. Returns its position as *-- with at(). Contrary to ANSI.C definition, returns *-- 0 if none of characters is found. *-- Written for.: dBASE IV *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>") *-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data") *-- Returns.....: Numeric value *-- Parameters..: cCharSet = characters to look for in cBigStr *-- cBigStr = string to look in *------------------------------------------------------------------------------- parameters cCharset, cBigstring private nPos, nLooklen nPos = 0 nLooklen = len( cBigstring ) do while nPos < nLooklen nPos = nPos + 1 if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0 exit endif enddo RETURN iif(nPos=nLookLen,0,nPos) *-- EoF: StrPBrk() PROCEDURE BlankIt *------------------------------------------------------------------------------- *-- Programmer..: Bill Garrison (BILLG), Roger Breckenridge *-- Date........: 01/08/1993 *-- Notes.......: Screen Saver from within dbase - uploaded to Public Domain *-- Written for.: dBase IV 1.5 (probably work with 1.1 though) *-- Rev. History: Original clock prg was from Michael Irwin, who I believe *-- : expanded on from source unknown. *-- : 10/29/1992: Modified original program received at *-- : Ashton-Tate Seminar a year or so ago. *-- : Fine tuned it and added moving window feature. *-- : 11/02/1992: Modified -- Ken Mayer -- dUFLP and added *-- : Jay's RECOLOR routine, as SET COLOR TO *-- does not reset properly. *-- 01/08/1992: Fixed ON KEY reset, which was to "Blanker", not *-- "Blankit". *-- Calls.......: CLOCKIT Procedure in MISC.PRG *-- : CLOCK Procedure in MISC.PRG *-- : RECOLOR Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: Do BLANKIT *-- Example.....: ON KEY LABEL Alt-B DO BlankIt *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- on key label alt-B && turn off key label that called this prg save screen to sBlanker private aTimeAll,nTX,nTY,cSpace,cTop,cBottom,cSide,lMary,nSec8,; clSet2,clSet3,cTalk,cCursor *-- save settings cCursor= set("CURSOR") cTalk = set("TALK") set cursor off set talk off *-- screen colors clSet2 = set("ATTRIBUTES") clSet3 = left(clset2,at(" ",clset2)-1) set color to N/N,N/N,N/N *-- blank screen lMary=.T. activate screen @0,0 fill to 24,79 color N/N store 0 to nTX,nTY *-- wait for user to do something ... do while lMary do clockit && display clock nTX=iif(nTX>16,0,nTX+2) nTY=iif(nTY>46,0,nTY+4) enddo *-- reset restore screen from sBlanker release screen sBlanker on key label alt-B do blankit && reset on key do recolor with clSet2 set cursor &cCursor. set talk &cTalk && reset talk & cursor to entry release aTimeAll,nTX,nTY,cSpace,cTop,cBottom,cSide,lMary,nSec8,clSet2,; clSet3,cCursor,cTime,nMin1,nMin2,cTalk RETURN *-- EoP: BlankIt PROCEDURE ClockIt *------------------------------------------------------------------------------- *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge *-- Date........: 10/29/1992 *-- Notes.......: Display clock for BLANKER routine. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: CLOCK Procedure in MISC.PRG *-- Called by...: BLANKIT Procedure in MISC.PRG *-- Usage.......: do clockit *-- Example.....: do clockit *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- declare aTime[11,3], aTimeAll[3] define window wClock from m->nTX,m->nTY to m->nTX+5,m->nTY+30 ; color W+/N+,,GR+/R activate window wClock do clock nSec8=1 do while nSec8<11 && increase/decrease movement frequency here cTime=iif(val(left(time(),2))>12,; str(val(left(time(),2))-12,2)+substr(time(),3,6),time()) nHour1=val(left(cTime,1))+1 nHour2=val(substr(cTime,2,1))+1 nMin1=val(substr(cTime,4,1))+1 nMin2=val(substr(cTime,5,1))+1 nSec1=val(substr(cTime,7,1))+1 nSec2=val(substr(cTime,8,1))+1 aTimeAll[1]=aTime[nHour1,1]+" "+aTime[nHour2,1]+aTime[11,1]+; aTime[nMin1,1]+" "+aTime[nMin2,1]+; aTime[11,1]+aTime[nSec1,1]+" "+aTime[nSec2,1] aTimeAll[2]=aTime[nHour1,2]+" "+aTime[nHour2,2]+aTime[11,2]+; aTime[nMin1,2]+" "+aTime[nMin2,2]+aTime[11,2]+; aTime[nSec1,2]+" "+aTime[nSec2,2] aTimeAll[3]=aTime[nHour1,3]+" "+aTime[nHour2,3]+aTime[11,3]+; aTime[nMin1,3]+" "+aTime[nMin2,3]+aTime[11,3]+; aTime[nSec1,3]+" "+aTime[nSec2,3] *-- display it @0,21 say ' '+iif(val(left(time(),2))>12,'P','A')+'.M.' @1,1 say aTimeAll[1] @2,1 say aTimeAll[2] @3,1 say aTimeAll[3] *-- get input from user? nSec8=nSec8+1 nWait=inkey(1) if nWait=27 && wait for <Esc> key lMary=.F. exit endif enddo release window wClock RETURN *-- EoP: ClockIt PROCEDURE Clock *------------------------------------------------------------------------------- *-- Programmer..: Bill Garrison (BILLG) and Roger Breckenridge *-- Date........: 10/29/1992 *-- Notes.......: Clock Routine (part of BLANKIT) -- defines outlines of clock *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: CLOCKIT Procedure in MISC.PRG *-- Usage.......: do clock *-- Example.....: do clock *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- cSpace = ' ' cTop = CHR(223) && ▀ cBottom = CHR(220) && ▄ cSide = CHR(219) && █ aTime[1,1]=cSide+cTop+cSide aTime[1,2]=cSide+cSpace+cSide aTime[1,3]=cTop+cTop+cTop aTime[2,1]=cSpace+cSpace+cSide aTime[2,2]=cSpace+cSpace+cSide aTime[2,3]=cSpace+cSpace+cTop aTime[3,1]=cTop+cTop+cSide aTime[3,2]=cSide+cTop+cTop aTime[3,3]=cTop+cTop+cTop aTime[4,1]=cTop+cTop+cSide aTime[4,2]=cSpace+cTop+cSide aTime[4,3]=cTop+cTop+cTop aTime[5,1]=cSide+cSpace+cSide aTime[5,2]=cTop+cTop+cSide aTime[5,3]=cSpace+cSpace+cTop aTime[6,1]=cSide+cTop+cTop aTime[6,2]=cTop+cTop+cSide aTime[6,3]=cTop+cTop+cTop aTime[7,1]=cSide+cTop+cTop aTime[7,2]=cSide+cTop+cSide aTime[7,3]=cTop+cTop+cTop aTime[8,1]=cTop+cTop+cSide aTime[8,2]=cSpace+cSpace+cSide aTime[8,3]=cSpace+cSpace+cTop aTime[9,1]=cSide+cTop+cSide aTime[9,2]=cSide+cTop+cSide aTime[9,3]=cTop+cTop+cTop aTime[10,1]=cSide+cTop+cSide aTime[10,2]=cTop+cTop+cSide aTime[10,3]=cTop+cTop+cTop aTime[11,1]=cSpace+cBottom+cSpace aTime[11,2]=cSpace+cBottom+cSpace aTime[11,3]=cSpace+cSpace+cSpace RETURN *-- EoP: ClockIt FUNCTION AuxMsg *------------------------------------------------------------------------------- *-- Programmer..: Bowen Moursund (CIS: 76566,1405) *-- From ideas by Robert Scola & Sal Ricciardi *-- published in PC Magazine, Volume 11, Number 21 *-- Date........: 11/21/1992 *-- Notes.......: AuxMsg will output a character string to the DOS AUX *-- device. If a dual monitor system is in use and the *-- DOS device driver OX.SYS is loaded, the string will *-- print on the mono monitor. Parameter 2 determines *-- whether the string is preceeded by a linefeed or not. *-- ********************************************************* *-- * OX.SYS must be loaded in CONFIG.SYS file, and machine * *-- * Booted with it ... * *-- ********************************************************* *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: AuxMsg( cMsg, lLF ) *-- Example.....: ? AuxMsg( time(), .t. ) *-- cJunk = AuxMsg( cMemVar, .f. ) *-- cJunk = AuxMsg( "Hello! ) *-- Returns.....: "" *-- Parameters..: cMsg = string to output to AUX *-- lLF = .t. or .f., linefeed or not *------------------------------------------------------------------------------- parameters cMsg, lLF private nAux, CRLF CRLF = chr(13) + chr(10) nAux = fopen( "aux", "w" ) if lLF l = fwrite( nAux, CRLF ) endif if type( "cMsg" ) = "C" l = fwrite( nAux, cMsg ) endif l = fclose( nAux ) RETURN "" *-- EoF: AuxMsg() FUNCTION Gcd *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 12/03/1992 *-- Notes.......: Greatest common divisor of two integers. Given two *-- integers, returns their largest common divisor. Returns *-- 0 if one or both are not integers, but returns the *-- absolute value of the gcd if one or both are negative. *-- If one is 0, returns the other. *-- Usually known as "Euclid's algorithm." *-- The algorithm used is discussed in 4.5.2 of *-- Volume II, "The Art of Computer Programming", 2d edition, *-- Addison-Wesley, Reading, MA, by Donald Knuth. *-- Written for.: dBASE IV, 1.1 and 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Gcd( <n1>, <n2> ) *-- Example.....: ? Gcd( 24140, 40902 ) *-- Returns.....: numeric, the Gcd, or 0 if not both integers ( 34 in example). *-- Parameters..: n1 = numeric, one of the integers *-- n2 = numeric, the other *------------------------------------------------------------------------------- parameters n1, n2 private nMin, nMax, nMod nMax = iif( int( n1 ) = n1 .and. int( n2 ) = n2, 1, 0 ) if nMax # 0 nMin = min( abs( n1 ), abs( n2 ) ) nMax = max( abs( n1 ), abs( n2 ) ) do while nMin > 0 nMod = mod( nMax, nMin ) nMax = nMin nMin = nMod enddo endif RETURN nMax *-- EoF: Gcd() FUNCTION RandSel *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 70160,340) *-- Date........: 12/03/1992 *-- Notes.......: Random selection of integers. The function requires *-- two numeric parameters, the number nN to select and the *-- number of items nT to select from. It fills the first *-- nN rows of a one-column array with an ordered random *-- selection of the integers from 1 to nT, which may of *-- course be used as record numbers or indices into some *-- other data structure to select items from it. If *-- passed a third, character, parameter, it will place the *-- selected numbers in the array of that name, otherwise in *-- the array "RandSel". If passed a fourth parameter *-- that evaluates to .T., it will reseed the random number *-- generator, otherwise use the next random numbers. *-- If the array does not exist, it will be created. If *-- it does exist but with two dimensions or too few rows, *-- it will be recreated with one dimension and enough rows. *-- If the first parameter is larger than the second, they *-- will be swapped. *-- The random-number generator should usually be reseeded, *-- either by using the "lReseed" parameter or before calling *-- the function, except where the function is being called *-- repeatedly either within a very short time or for related *-- applications in which a repetition of the sequence would *-- defeat the randomness. *-- For dBASE IV versions before 1.5, revise this to take *-- only the two numeric parameters by commenting out the first *-- "parameters" line of code below and including the next *-- three commented lines. The array "RandSel" will be used, *-- and reseeding if needed must be done before calling the *-- function. *-- The algorithm used is "Algorithm S" discussed *-- in 3.4.2 of Volume II, "The Art of Computer Programming", *-- 2d edition, Addison-Wesley, Reading, MA, by Donald Knuth. *-- Written for.: dBASE IV, 1.1 and 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: RandSel( "<nN>,<nT> [,<cArray>] [,<lReseed>]" ) *-- Example.....: lX = RandSel( 100, reccount(), "MyArray", .T. ) *-- Returns.....: .T. if successful, or .F. if given number < 1 as parameter. *-- Parameters..: nN = numeric, number of integers to select *-- nT = numeric, highest integer to select from *-- cArray = character, name of the array to hold the *-- selected integers. If not furnished, array *-- "RandSel" will be used. *-- lReseed = logical, .T. to reseed the random-number *-- generator. Default is .F., no reseed. *-- Side effects: Creates as needed and fills the array. *-- Uses some random numbers from the sequence. *------------------------------------------------------------------------------- parameters nN, nT, cArray, lReseed *-- users of versions below 1.5, comment out the line above and include *-- the three lines below * parameters nN, nT * private cArray, lReseed * store .F. to cArray, lReseed private nChoose, nTotal, lReturn, nX, nChosen, nSeen nChoose = int( min( nN, nT ) ) nTotal = int( max( nN, nT ) ) lReturn = ( nChoose >= 1 ) if lReturn if type( "cArray" ) = "L" cArray = "RandSel" endif if type( "&cArray.[ nT ]" ) = "U" release &cArray public &cArray declare &cArray.[ nT ] endif if lReseed nX = rand( -1 ) endif store 0 to nChosen, nSeen do while nChosen < nChoose nX = rand() * ( nTotal - nSeen ) if nX < nChoose - nChosen nChosen = nChosen + 1 &cArray.[ nChosen ] = nSeen + 1 endif nSeen = nSeen + 1 enddo endif RETURN lReturn *-- EoF: RandSel() *------------------------------------------------------------------------------- *-- EoP: MISC.PRG *-------------------------------------------------------------------------------